#lang racket

(require (for-syntax "travers.rkt") (for-syntax syntax/parse))
(provide define-lock λ-lock lambda-lock ARITY-ERROR)
(define ARITY-ERROR '(incorrect arity for lock))

;; defines a Lock. Used like a regular function deffintion define lock turns a normal [Any ... -> Any] function deffinition into a Lock
;; i.e. if the exp evaluates to true, #t is returned, else the binding list calculated by define-lock

;; NOTE:
;; currently lambda-lock does not suport macros of any form except:
;; -- let
;; -- let*
;; -- letrec
;; Lambda acts as an 'obscurer': anything in a lambda is unparseable by lambda-lock. Any form may be used in lambda, and its bindings will not(and cannot)
;;  be viewed in the lock's output
(define-syntax (define-lock stx)
  (syntax-parse stx
    [(define-lock (name arg ...) exp)
     #`(define name (lambda-lock (arg ...) exp))]))

(define-syntax (λ-lock stx)
  (syntax-parse stx
    [(λ-lock (arg ...) exp)
     #`(lambda-lock (arg ...) exp)]))

(define-syntax (lambda-lock stx)
  (syntax-parse stx
    [(lambda-lock (arg ...) exp)
     #`(lambda args
         (with-handlers*
          ([exn:fail? (λ (e) ARITY-ERROR)])
          (apply (lambda (arg ...)
                   (let ([binding-list (append (get-bound exp) (get-unbound 'exp))])
                     (with-handlers* ([exn:fail? (λ (e) `(exeption: ,e binding-list: ,binding-list))])
                                     (if exp #t binding-list))))
                 args)))]))


;; Expr -> BindingList
;; gets all atoms in the expression
(define (get-unbound exp)
  (cond [(empty? exp) null]
        [(symbol? exp) null]
        [(and (cons? exp)
              (symbol? (car exp))
              (or (symbol=? 'λ (car exp))
                  (symbol=? 'lambda (car exp))))
         (list (list 'const (list (car exp) (cadr exp) '...)))]
        [(and (cons? exp)
              (and (symbol? (car exp))
                   (equal? 'quote (car exp))))
         (list (list 'const (cadr `(quote ,exp))))]
        [(and (cons? exp)
              (not (and (symbol? (car exp))
                        (equal? 'quote (car exp)))))
         (append (get-unbound (car exp))
                 (get-unbound (cdr exp)))]
        [else (list (list 'const exp))]))

;; Syntax -> BindingList
;; gets all bound values in the given exp
;; FIXME: breaks on macros, and bindings
(define-syntax (get-bound stx)
  (syntax-parse stx
                [(get-bound exp)
                 (let ([bindings (travers (syntax->datum #'exp) #'exp)])
                   #`(list #,@bindings))]))